home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 19 / CD_ASCQ_19_010295.iso / dos / prg / pas / swag / screen.swg / 0073_Screen Fun - Cascade And WipeIt!.pas < prev    next >
Pascal/Delphi Source File  |  1994-11-30  |  5KB  |  144 lines
  1. {
  2. A while back someone asked for a "cascade" type screen thingy, and a also a
  3. screen wipe that would look sort of like a TV screen powering down... Here
  4. they are... & I would like them to get into the next SWAG... 8)
  5. }
  6. Program Cascade1;
  7.  
  8. {causes entire screen to "fall", character by character, to the bottom of the }
  9. {     screen...                                                               }
  10. {                                                                             }
  11. {              Released for SWAG use!  Use freely!                            }
  12. {                                                                             }
  13. {   But if you do use it, please let me know...                               }
  14. {                                                                             }
  15. {         Allen Walker  - Crazy Train ][  (604)383-2201                       }
  16. {                                                                             }
  17.  
  18. Uses CRT;
  19.  
  20. Var MGAScreenMem:Array[0..1999] of Word Absolute $B000:0000;
  21.     CGAScreenMem:Array[0..1999] of Word Absolute $B800:0000;
  22.  
  23. Function Mono_Colour:Boolean;
  24. {Mono = False, Color = True}
  25. Var I,J,X,Y:Integer;
  26.     A,B,C,D:Word;
  27. begin
  28.   X:=WhereX-1; Y:=WhereY-1;
  29.   C:=MGAScreenMem[Y*80+X]; D:=CGAScreenMem[Y*80+X];
  30.   Write('A'+Chr(8));
  31.   A:=MGAScreenMem[Y*80+X]; B:=CGAScreenMem[Y*80+X];
  32.   MGAScreenMem[Y*80+X]:=C; CGAScreenMem[Y*80+X]:=D;
  33.   If (A mod 256) =$41 then begin Mono_Colour:=False; Exit; end;
  34.   If (B mod 256) =$41 then begin Mono_Colour:=True; Exit; end;
  35. end;
  36.  
  37. Procedure Cascade;
  38. Var L,I,X : Word;
  39.     MC    : Boolean;
  40. begin
  41.   MC:=Mono_Colour;
  42.   For L:=1 to 25 do
  43.   begin
  44.     For I:=1999 downto 80 do
  45.     begin
  46.       If MC then
  47.       begin
  48.         If (CGAScreenMem[I] and $70FF =32) and
  49.                      (CGAScreenMem[I-80] and $70FF <>32) then
  50.         begin
  51.           X:=CGAScreenMem[I]; CGAScreenMem[I]:=CGAScreenMem[I-80];
  52.           CGAScreenMem[I-80]:=X;
  53.         end;
  54.       end
  55.         else
  56.       begin
  57.         If (MGAScreenMem[I] and $70FF =32) and
  58.                      (MGAScreenMem[I-80] and $70FF <>32) then
  59.         begin
  60.           X:=MGAScreenMem[I]; MGAScreenMem[I]:=MGAScreenMem[I-80];
  61.           MGAScreenMem[I-80]:=X;
  62.         end;
  63.       end;
  64.     end;
  65.       Delay(100);
  66.   end;
  67. end;
  68.  
  69. begin
  70.   Cascade;
  71. end.
  72.  
  73.  
  74.  
  75.  
  76.  
  77. Program CRTWipe;
  78. {Causes screen to wipe from bottom & top towards the middle, then from the    }
  79. {   sides to the center...                                                    }
  80. {                                                                             }
  81. {              Released for SWAG use!  Use freely!                            }
  82. {                                                                             }
  83. {   But if you do use it, please let me know...                               }
  84. {                                                                             }
  85. {         Allen Walker  - Crazy Train ][  (604)383-2201                       }
  86. {                                                                             }
  87. Uses CRT;
  88.  
  89. Var MGAScreenMem:Array[0..1999] of Word Absolute $B000:0000;
  90.     CGAScreenMem:Array[0..1999] of Word Absolute $B800:0000;
  91.     MC : Boolean;
  92.  
  93. Function Mono_Colour:Boolean;
  94. {Mono = False, Color = True}
  95. Var I,J,X,Y:Integer;
  96.     A,B,C,D:Word;
  97. begin
  98.   X:=WhereX-1; Y:=WhereY-1;
  99.   C:=MGAScreenMem[Y*80+X]; D:=CGAScreenMem[Y*80+X];
  100.   Write('A'+Chr(8));
  101.   A:=MGAScreenMem[Y*80+X]; B:=CGAScreenMem[Y*80+X];
  102.   MGAScreenMem[Y*80+X]:=C; CGAScreenMem[Y*80+X]:=D;
  103.   If (A mod 256) =$41 then begin Mono_Colour:=False; Exit; end;
  104.   If (B mod 256) =$41 then begin Mono_Colour:=True; Exit; end;
  105. end;
  106.  
  107. Procedure SetChar(N,Z:Word);
  108. begin
  109.   If MC then CGAScreenMem[N]:=Z else MGAScreenMem[N]:=Z;
  110. end;
  111.  
  112. Function ReadChar(N:Word):Word;
  113. begin
  114.   If MC then ReadChar:=CGAScreenMem[N] else ReadChar:=MGAScreenMem[N];
  115. end;
  116.  
  117. Procedure WipeIt;
  118. Var L,X,Y,Z : Word;
  119. begin
  120.   MC:=Mono_Colour;
  121.   For L:=1 to 12 do
  122.   For Y:=12 downto 0 do
  123.   begin
  124.     For X:=0 to 79 do
  125.     begin
  126.       Z:=ReadChar(X+(80*Y)); SetChar(X+(80*Y)+80,Z); SetChar(X+(80*Y),1792);
  127.     end;
  128.     For X:=0 to 79 do
  129.     begin
  130.       Z:=ReadChar(X+(80*(25-Y))); SetChar(X+(80*(25-Y))-80,Z);
  131.       SetChar(X+(80*(25-Y)),1792);
  132.     end;
  133.   end;
  134.   Delay(100);
  135.   For X:=0 to 39 do
  136.   begin
  137.     SetChar(X+960,1792); SetChar(1039-X,1792); Delay(10);
  138.   end;
  139. end;
  140.  
  141. begin
  142.   WipeIt;
  143. end.
  144.